home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume6 / xlisp1.6 / part2 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  58.6 KB
  1. Subject:  v06i108:  Xlisp version 1.6 (xlisp1.6), Part01/06
  2. Newsgroups: mod.sources
  3. Approved: rs@mirror.UUCP
  4.  
  5. Submitted by: seismo!utah-cs!b-davis (Brad Davis)
  6. Mod.sources: Volume 6, Issue 108
  7. Archive-name: xlisp1.6/Part01
  8.  
  9. #! /bin/sh
  10. # This is a shell archive, meaning:
  11. # 1. Remove everything above the #! /bin/sh line.
  12. # 2. Save the resulting text in a file.
  13. # 3. Execute the file with /bin/sh (not csh) to create the files:
  14. #    xlfio.c
  15. #    xlftab.c
  16. #    xlglob.c
  17. #    xlinit.c
  18. #    xlio.c
  19. #    xlisp.c
  20. #    xljump.c
  21. #    xllist.c
  22. #    xlmath.c
  23. # This archive created: Mon Jul 14 10:22:46 1986
  24. export PATH; PATH=/bin:$PATH
  25. if test -f 'xlfio.c'
  26. then
  27.     echo shar: will not over-write existing file "'xlfio.c'"
  28. else
  29. cat << \SHAR_EOF > 'xlfio.c'
  30. /* xlfio.c - xlisp file i/o */
  31. /*    Copyright (c) 1985, by David Michael Betz
  32.     All Rights Reserved
  33.     Permission is granted for unrestricted non-commercial use    */
  34.  
  35. #include "xlisp.h"
  36.  
  37. #ifdef MEGAMAX
  38. overlay "io"
  39. #endif
  40.  
  41. /* external variables */
  42. extern NODE *s_stdin,*s_stdout,*true;
  43. extern NODE ***xlstack;
  44. extern int xlfsize;
  45. extern char buf[];
  46.  
  47. /* external routines */
  48. extern FILE *fopen();
  49.  
  50. /* forward declarations */
  51. FORWARD NODE *printit();
  52. FORWARD NODE *flatsize();
  53. FORWARD NODE *openit();
  54.  
  55. /* xread - read an expression */
  56. NODE *xread(args)
  57.   NODE *args;
  58. {
  59.     NODE ***oldstk,*fptr,*eof,*rflag,*val;
  60.  
  61.     /* create a new stack frame */
  62.     oldstk = xlsave(&fptr,&eof,(NODE **)NULL);
  63.  
  64.     /* get file pointer and eof value */
  65.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  66.     eof = (args ? xlarg(&args) : NIL);
  67.     rflag = (args ? xlarg(&args) : NIL);
  68.     xllastarg(args);
  69.  
  70.     /* read an expression */
  71.     if (!xlread(fptr,&val,rflag != NIL))
  72.     val = eof;
  73.  
  74.     /* restore the previous stack frame */
  75.     xlstack = oldstk;
  76.  
  77.     /* return the expression */
  78.     return (val);
  79. }
  80.  
  81. /* xprint - built-in function 'print' */
  82. NODE *xprint(args)
  83.   NODE *args;
  84. {
  85.     return (printit(args,TRUE,TRUE));
  86. }
  87.  
  88. /* xprin1 - built-in function 'prin1' */
  89. NODE *xprin1(args)
  90.   NODE *args;
  91. {
  92.     return (printit(args,TRUE,FALSE));
  93. }
  94.  
  95. /* xprinc - built-in function princ */
  96. NODE *xprinc(args)
  97.   NODE *args;
  98. {
  99.     return (printit(args,FALSE,FALSE));
  100. }
  101.  
  102. /* xterpri - terminate the current print line */
  103. NODE *xterpri(args)
  104.   NODE *args;
  105. {
  106.     NODE *fptr;
  107.  
  108.     /* get file pointer */
  109.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  110.     xllastarg(args);
  111.  
  112.     /* terminate the print line and return nil */
  113.     xlterpri(fptr);
  114.     return (NIL);
  115. }
  116.  
  117. /* printit - common print function */
  118. LOCAL NODE *printit(args,pflag,tflag)
  119.   NODE *args; int pflag,tflag;
  120. {
  121.     NODE ***oldstk,*fptr,*val;
  122.  
  123.     /* create a new stack frame */
  124.     oldstk = xlsave(&fptr,&val,(NODE **)NULL);
  125.  
  126.     /* get expression to print and file pointer */
  127.     val = xlarg(&args);
  128.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  129.     xllastarg(args);
  130.  
  131.     /* print the value */
  132.     xlprint(fptr,val,pflag);
  133.  
  134.     /* terminate the print line if necessary */
  135.     if (tflag)
  136.     xlterpri(fptr);
  137.  
  138.     /* restore the previous stack frame */
  139.     xlstack = oldstk;
  140.  
  141.     /* return the result */
  142.     return (val);
  143. }
  144.  
  145. /* xflatsize - compute the size of a printed representation using prin1 */
  146. NODE *xflatsize(args)
  147.   NODE *args;
  148. {
  149.     return (flatsize(args,TRUE));
  150. }
  151.  
  152. /* xflatc - compute the size of a printed representation using princ */
  153. NODE *xflatc(args)
  154.   NODE *args;
  155. {
  156.     return (flatsize(args,FALSE));
  157. }
  158.  
  159. /* flatsize - compute the size of a printed expression */
  160. LOCAL NODE *flatsize(args,pflag)
  161.   NODE *args; int pflag;
  162. {
  163.     NODE ***oldstk,*val;
  164.  
  165.     /* create a new stack frame */
  166.     oldstk = xlsave(&val,(NODE **)NULL);
  167.  
  168.     /* get the expression */
  169.     val = xlarg(&args);
  170.     xllastarg(args);
  171.  
  172.     /* print the value to compute its size */
  173.     xlfsize = 0;
  174.     xlprint(NIL,val,pflag);
  175.  
  176.     /* restore the previous stack frame */
  177.     xlstack = oldstk;
  178.  
  179.     /* return the length of the expression */
  180.     return (cvfixnum((FIXNUM)xlfsize));
  181. }
  182.  
  183. /* xopeni - open an input file */
  184. NODE *xopeni(args)
  185.   NODE *args;
  186. {
  187.     return (openit(args,"r"));
  188. }
  189.  
  190. /* xopeno - open an output file */
  191. NODE *xopeno(args)
  192.   NODE *args;
  193. {
  194.     return (openit(args,"w"));
  195. }
  196.  
  197. /* openit - common file open routine */
  198. LOCAL NODE *openit(args,mode)
  199.   NODE *args; char *mode;
  200. {
  201.     NODE *fname,*val;
  202.     char *name;
  203.     FILE *fp;
  204.  
  205.     /* get the file name */
  206.     fname = xlarg(&args);
  207.     xllastarg(args);
  208.  
  209.     /* get the name string */
  210.     if (symbolp(fname))
  211.     name = getstring(getpname(fname));
  212.     else if (stringp(fname))
  213.     name = getstring(fname);
  214.     else
  215.     xlfail("bad argument type",fname);
  216.  
  217.     /* try to open the file */
  218.     if ((fp = fopen(name,mode)) != NULL)
  219.     val = cvfile(fp);
  220.     else
  221.     val = NIL;
  222.  
  223.     /* return the file pointer */
  224.     return (val);
  225. }
  226.  
  227. /* xclose - close a file */
  228. NODE *xclose(args)
  229.   NODE *args;
  230. {
  231.     NODE *fptr;
  232.  
  233.     /* get file pointer */
  234.     fptr = xlmatch(FPTR,&args);
  235.     xllastarg(args);
  236.  
  237.     /* make sure the file exists */
  238.     if (getfile(fptr) == NULL)
  239.     xlfail("file not open");
  240.  
  241.     /* close the file */
  242.     fclose(getfile(fptr));
  243.     setfile(fptr,NULL);
  244.  
  245.     /* return nil */
  246.     return (NIL);
  247. }
  248.  
  249. /* xrdchar - read a character from a file */
  250. NODE *xrdchar(args)
  251.   NODE *args;
  252. {
  253.     NODE *fptr;
  254.     int ch;
  255.  
  256.     /* get file pointer */
  257.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  258.     xllastarg(args);
  259.  
  260.     /* get character and check for eof */
  261.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
  262. }
  263.  
  264. /* xpkchar - peek at a character from a file */
  265. NODE *xpkchar(args)
  266.   NODE *args;
  267. {
  268.     NODE *flag,*fptr;
  269.     int ch;
  270.  
  271.     /* peek flag and get file pointer */
  272.     flag = (args ? xlarg(&args) : NIL);
  273.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  274.     xllastarg(args);
  275.  
  276.     /* skip leading white space and get a character */
  277.     if (flag)
  278.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  279.         xlgetc(fptr);
  280.     else
  281.     ch = xlpeek(fptr);
  282.  
  283.     /* return the character */
  284.     return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
  285. }
  286.  
  287. /* xwrchar - write a character to a file */
  288. NODE *xwrchar(args)
  289.   NODE *args;
  290. {
  291.     NODE *fptr,*chr;
  292.  
  293.     /* get the character and file pointer */
  294.     chr = xlmatch(INT,&args);
  295.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  296.     xllastarg(args);
  297.  
  298.     /* put character to the file */
  299.     xlputc(fptr,(int)getfixnum(chr));
  300.  
  301.     /* return the character */
  302.     return (chr);
  303. }
  304.  
  305. /* xreadline - read a line from a file */
  306. NODE *xreadline(args)
  307.   NODE *args;
  308. {
  309.     NODE ***oldstk,*fptr,*str,*newstr;
  310.     int len,blen,ch;
  311.     char *p,*sptr;
  312.  
  313.     /* create a new stack frame */
  314.     oldstk = xlsave(&fptr,&str,(NODE **)NULL);
  315.  
  316.     /* get file pointer */
  317.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  318.     xllastarg(args);
  319.  
  320.     /* get character and check for eof */
  321.     len = blen = 0; p = buf;
  322.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  323.  
  324.     /* check for buffer overflow */
  325.     if (blen >= STRMAX) {
  326.          newstr = newstring(len+STRMAX);
  327.         sptr = getstring(newstr); *sptr = 0;
  328.         if (str) strcat(sptr,getstring(str));
  329.         *p = 0; strcat(sptr,buf);
  330.         p = buf; blen = 0;
  331.         len += STRMAX;
  332.         str = newstr;
  333.     }
  334.  
  335.     /* store the character */
  336.     *p++ = ch; blen++;
  337.     }
  338.  
  339.     /* check for end of file */
  340.     if (len == 0 && p == buf && ch == EOF) {
  341.     xlstack = oldstk;
  342.     return (NIL);
  343.     }
  344.  
  345.     /* append the last substring */
  346.     if (str == NIL || blen) {
  347.     newstr = newstring(len+blen);
  348.     sptr = getstring(newstr); *sptr = 0;
  349.     if (str) strcat(sptr,getstring(str));
  350.     *p = 0; strcat(sptr,buf);
  351.     str = newstr;
  352.     }
  353.  
  354.     /* restore the previous stack frame */
  355.     xlstack = oldstk;
  356.  
  357.     /* return the string */
  358.     return (str);
  359. }
  360.  
  361. SHAR_EOF
  362. fi # end of overwriting check
  363. if test -f 'xlftab.c'
  364. then
  365.     echo shar: will not over-write existing file "'xlftab.c'"
  366. else
  367. cat << \SHAR_EOF > 'xlftab.c'
  368. /* xlftab.c - xlisp function table */
  369. /*    Copyright (c) 1985, by David Michael Betz
  370.     All Rights Reserved
  371.     Permission is granted for unrestricted non-commercial use    */
  372.  
  373. #include "xlisp.h"
  374.  
  375. /* external functions */
  376. extern NODE
  377.     *xeval(),*xapply(),*xfuncall(),*xquote(),*xfunction(),*xbquote(),
  378.     *xlambda(),*xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
  379.     *xgensym(),*xmakesymbol(),*xintern(),
  380.     *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xputprop(),*xremprop(),
  381.     *xhash(),*xmkarray(),*xaref(),
  382.     *xcar(),*xcdr(),
  383.     *xcaar(),*xcadr(),*xcdar(),*xcddr(),
  384.     *xcaaar(),*xcaadr(),*xcadar(),*xcaddr(),
  385.     *xcdaar(),*xcdadr(),*xcddar(),*xcdddr(),
  386.     *xcaaaar(),*xcaaadr(),*xcaadar(),*xcaaddr(),
  387.     *xcadaar(),*xcadadr(),*xcaddar(),*xcadddr(),
  388.     *xcdaaar(),*xcdaadr(),*xcdadar(),*xcdaddr(),
  389.     *xcddaar(),*xcddadr(),*xcdddar(),*xcddddr(),
  390.     *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
  391.     *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
  392.     *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
  393.     *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
  394.     *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
  395.     *xeq(),*xeql(),*xequal(),
  396.     *xcond(),*xcase(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
  397.     *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
  398.     *xcatch(),*xthrow(),
  399.     *xerror(),*xcerror(),*xbreak(),*xcleanup(),*xcontinue(),*xerrset(),
  400.     *xbaktrace(),*xevalhook(),
  401.     *xdo(),*xdostar(),*xdolist(),*xdotimes(),
  402.     *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
  403.     *xfix(),*xfloat(),
  404.     *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
  405.     *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
  406.     *xsin(),*xcos(),*xtan(),*xexpt(),*xexp(),*xsqrt(),*xrand(),
  407.     *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
  408.     *xstrcat(),*xsubstr(),*xstring(),*xchar(),
  409.     *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
  410.     *xflatsize(),*xflatc(),
  411.     *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
  412.     *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
  413.  
  414.  
  415. /* the function table */
  416. struct fdef ftab[] = {
  417.  
  418.     /* evaluator functions */
  419. {    "EVAL",        SUBR,    xeval        },
  420. {    "APPLY",    SUBR,    xapply        },
  421. {    "FUNCALL",    SUBR,    xfuncall    },
  422. {    "QUOTE",    FSUBR,    xquote        },
  423. {    "FUNCTION",    FSUBR,    xfunction    },
  424. {    "BACKQUOTE",    FSUBR,    xbquote        },
  425. {    "LAMBDA",    FSUBR,    xlambda        },
  426.  
  427.     /* symbol functions */
  428. {    "SET",        SUBR,    xset        },
  429. {    "SETQ",        FSUBR,    xsetq        },
  430. {    "SETF",        FSUBR,    xsetf        },
  431. {    "DEFUN",    FSUBR,    xdefun        },
  432. {    "DEFMACRO",    FSUBR,    xdefmacro    },
  433. {    "GENSYM",    SUBR,    xgensym        },
  434. {    "MAKE-SYMBOL",    SUBR,    xmakesymbol    },
  435. {    "INTERN",    SUBR,    xintern        },
  436. {    "SYMBOL-NAME",    SUBR,    xsymname    },
  437. {    "SYMBOL-VALUE",    SUBR,    xsymvalue    },
  438. {    "SYMBOL-PLIST",    SUBR,    xsymplist    },
  439. {    "GET",        SUBR,    xget        },
  440. {    "PUTPROP",    SUBR,    xputprop    },
  441. {    "REMPROP",    SUBR,    xremprop    },
  442. {    "HASH",        SUBR,    xhash        },
  443.  
  444.     /* array functions */
  445. {    "MAKE-ARRAY",    SUBR,    xmkarray    },
  446. {    "AREF",        SUBR,    xaref        },
  447.  
  448.     /* list functions */
  449. {    "CAR",        SUBR,    xcar        },
  450. {    "CDR",        SUBR,    xcdr        },
  451.  
  452. {    "CAAR",        SUBR,    xcaar        },
  453. {    "CADR",        SUBR,    xcadr        },
  454. {    "CDAR",        SUBR,    xcdar        },
  455. {    "CDDR",        SUBR,    xcddr        },
  456.  
  457. {    "CAAAR",    SUBR,    xcaaar        },
  458. {    "CAADR",    SUBR,    xcaadr        },
  459. {    "CADAR",    SUBR,    xcadar        },
  460. {    "CADDR",    SUBR,    xcaddr        },
  461. {    "CDAAR",    SUBR,    xcdaar        },
  462. {    "CDADR",    SUBR,    xcdadr        },
  463. {    "CDDAR",    SUBR,    xcddar        },
  464. {    "CDDDR",    SUBR,    xcdddr        },
  465.  
  466. {    "CAAAAR",    SUBR,    xcaaaar        },
  467. {    "CAAADR",    SUBR,    xcaaadr        },
  468. {    "CAADAR",    SUBR,    xcaadar        },
  469. {    "CAADDR",    SUBR,    xcaaddr        },
  470. {    "CADAAR",    SUBR,    xcadaar        },
  471. {    "CADADR",    SUBR,    xcadadr        },
  472. {    "CADDAR",    SUBR,    xcaddar        },
  473. {    "CADDDR",    SUBR,    xcadddr        },
  474. {    "CDAAAR",    SUBR,    xcdaaar        },
  475. {    "CDAADR",    SUBR,    xcdaadr        },
  476. {    "CDADAR",    SUBR,    xcdadar        },
  477. {    "CDADDR",    SUBR,    xcdaddr        },
  478. {    "CDDAAR",    SUBR,    xcddaar        },
  479. {    "CDDADR",    SUBR,    xcddadr        },
  480. {    "CDDDAR",    SUBR,    xcdddar        },
  481. {    "CDDDDR",    SUBR,    xcddddr        },
  482.  
  483. {    "CONS",        SUBR,    xcons        },
  484. {    "LIST",        SUBR,    xlist        },
  485. {    "APPEND",    SUBR,    xappend        },
  486. {    "REVERSE",    SUBR,    xreverse    },
  487. {    "LAST",        SUBR,    xlast        },
  488. {    "NTH",        SUBR,    xnth        },
  489. {    "NTHCDR",    SUBR,    xnthcdr        },
  490. {    "MEMBER",    SUBR,    xmember        },
  491. {    "ASSOC",    SUBR,    xassoc        },
  492. {    "SUBST",    SUBR,    xsubst        },
  493. {    "SUBLIS",    SUBR,    xsublis        },
  494. {    "REMOVE",    SUBR,    xremove        },
  495. {    "LENGTH",    SUBR,    xlength        },
  496. {    "MAPC",        SUBR,    xmapc        },
  497. {    "MAPCAR",    SUBR,    xmapcar        },
  498. {    "MAPL",        SUBR,    xmapl        },
  499. {    "MAPLIST",    SUBR,    xmaplist    },
  500.  
  501.     /* destructive list functions */
  502. {    "RPLACA",    SUBR,    xrplca        },
  503. {    "RPLACD",    SUBR,    xrplcd        },
  504. {    "NCONC",    SUBR,    xnconc        },
  505. {    "DELETE",    SUBR,    xdelete        },
  506.  
  507.     /* predicate functions */
  508. {    "ATOM",        SUBR,    xatom        },
  509. {    "SYMBOLP",    SUBR,    xsymbolp    },
  510. {    "NUMBERP",    SUBR,    xnumberp    },
  511. {    "BOUNDP",    SUBR,    xboundp        },
  512. {    "NULL",        SUBR,    xnull        },
  513. {    "NOT",        SUBR,    xnull        },
  514. {    "LISTP",    SUBR,    xlistp        },
  515. {    "CONSP",    SUBR,    xconsp        },
  516. {    "MINUSP",    SUBR,    xminusp        },
  517. {    "ZEROP",    SUBR,    xzerop        },
  518. {    "PLUSP",    SUBR,    xplusp        },
  519. {    "EVENP",    SUBR,    xevenp        },
  520. {    "ODDP",        SUBR,    xoddp        },
  521. {    "EQ",        SUBR,    xeq        },
  522. {    "EQL",        SUBR,    xeql        },
  523. {    "EQUAL",    SUBR,    xequal        },
  524.  
  525.     /* control functions */
  526. {    "COND",        FSUBR,    xcond        },
  527. {    "CASE",        FSUBR,    xcase        },
  528. {    "AND",        FSUBR,    xand        },
  529. {    "OR",        FSUBR,    xor        },
  530. {    "LET",        FSUBR,    xlet        },
  531. {    "LET*",        FSUBR,    xletstar    },
  532. {    "IF",        FSUBR,    xif        },
  533. {    "PROG",        FSUBR,    xprog        },
  534. {    "PROG*",    FSUBR,    xprogstar    },
  535. {    "PROG1",    FSUBR,    xprog1        },
  536. {    "PROG2",    FSUBR,    xprog2        },
  537. {    "PROGN",    FSUBR,    xprogn        },
  538. {    "GO",        FSUBR,    xgo        },
  539. {    "RETURN",    SUBR,    xreturn        },
  540. {    "DO",        FSUBR,    xdo        },
  541. {    "DO*",        FSUBR,    xdostar        },
  542. {    "DOLIST",    FSUBR,    xdolist        },
  543. {    "DOTIMES",    FSUBR,    xdotimes    },
  544. {    "CATCH",    FSUBR,    xcatch        },
  545. {    "THROW",    SUBR,    xthrow        },
  546.  
  547.     /* debugging and error handling functions */
  548. {    "ERROR",    SUBR,    xerror        },
  549. {    "CERROR",    SUBR,    xcerror        },
  550. {    "BREAK",    SUBR,    xbreak        },
  551. {    "CLEAN-UP",    SUBR,    xcleanup    },
  552. {    "CONTINUE",    SUBR,    xcontinue    },
  553. {    "ERRSET",    FSUBR,    xerrset        },
  554. {    "BAKTRACE",    SUBR,    xbaktrace    },
  555. {    "EVALHOOK",    SUBR,    xevalhook    },
  556.  
  557.     /* arithmetic functions */
  558. {    "TRUNCATE",    SUBR,    xfix        },
  559. {    "FLOAT",    SUBR,    xfloat        },
  560. {    "+",        SUBR,    xadd        },
  561. {    "-",        SUBR,    xsub        },
  562. {    "*",        SUBR,    xmul        },
  563. {    "/",        SUBR,    xdiv        },
  564. {    "1+",        SUBR,    xadd1        },
  565. {    "1-",        SUBR,    xsub1        },
  566. {    "REM",        SUBR,    xrem        },
  567. {    "MIN",        SUBR,    xmin        },
  568. {    "MAX",        SUBR,    xmax        },
  569. {    "ABS",        SUBR,    xabs        },
  570. {    "SIN",        SUBR,    xsin        },
  571. {    "COS",        SUBR,    xcos        },
  572. {    "TAN",        SUBR,    xtan        },
  573. {    "EXPT",        SUBR,    xexpt        },
  574. {    "EXP",        SUBR,    xexp        },
  575. {    "SQRT",        SUBR,    xsqrt        },
  576. {    "RANDOM",    SUBR,    xrand        },
  577.  
  578.     /* bitwise logical functions */
  579. {    "BIT-AND",    SUBR,    xbitand        },
  580. {    "BIT-IOR",    SUBR,    xbitior        },
  581. {    "BIT-XOR",    SUBR,    xbitxor        },
  582. {    "BIT-NOT",    SUBR,    xbitnot        },
  583.  
  584.     /* numeric comparison functions */
  585. {    "<",        SUBR,    xlss        },
  586. {    "<=",        SUBR,    xleq        },
  587. {    "=",        SUBR,    xequ        },
  588. {    "/=",        SUBR,    xneq        },
  589. {    ">=",        SUBR,    xgeq        },
  590. {    ">",        SUBR,    xgtr        },
  591.  
  592.     /* string functions */
  593. {    "STRCAT",    SUBR,    xstrcat        },
  594. {    "SUBSTR",    SUBR,    xsubstr        },
  595. {    "STRING",    SUBR,    xstring        },
  596. {    "CHAR",        SUBR,    xchar        },
  597.  
  598.     /* I/O functions */
  599. {    "READ",        SUBR,    xread        },
  600. {    "PRINT",    SUBR,    xprint        },
  601. {    "PRIN1",    SUBR,    xprin1        },
  602. {    "PRINC",    SUBR,    xprinc        },
  603. {    "TERPRI",    SUBR,    xterpri        },
  604. {    "FLATSIZE",    SUBR,    xflatsize    },
  605. {    "FLATC",    SUBR,    xflatc        },
  606.  
  607.     /* file I/O functions */
  608. {    "OPENI",    SUBR,    xopeni        },
  609. {    "OPENO",    SUBR,    xopeno        },
  610. {    "CLOSE",    SUBR,    xclose        },
  611. {    "READ-CHAR",    SUBR,    xrdchar        },
  612. {    "PEEK-CHAR",    SUBR,    xpkchar        },
  613. {    "WRITE-CHAR",    SUBR,    xwrchar        },
  614. {    "READ-LINE",    SUBR,    xreadline    },
  615.  
  616.     /* system functions */
  617. {    "LOAD",        SUBR,    xload        },
  618. {    "GC",        SUBR,    xgc        },
  619. {    "EXPAND",    SUBR,    xexpand        },
  620. {    "ALLOC",    SUBR,    xalloc        },
  621. {    "MEM",        SUBR,    xmem        },
  622. {    "TYPE-OF",    SUBR,    xtype        },
  623. {    "EXIT",        SUBR,    xexit        },
  624.  
  625. {    0                    }
  626. };
  627.  
  628. SHAR_EOF
  629. fi # end of overwriting check
  630. if test -f 'xlglob.c'
  631. then
  632.     echo shar: will not over-write existing file "'xlglob.c'"
  633. else
  634. cat << \SHAR_EOF > 'xlglob.c'
  635. /* xlglobals - xlisp global variables */
  636. /*    Copyright (c) 1985, by David Michael Betz
  637.     All Rights Reserved
  638.     Permission is granted for unrestricted non-commercial use    */
  639.  
  640. #include "xlisp.h"
  641.  
  642. /* symbols */
  643. NODE *true = NIL, *s_dot = NIL;
  644. NODE *s_quote = NIL, *s_function = NIL;
  645. NODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
  646. NODE *s_evalhook = NIL, *s_applyhook = NIL;
  647. NODE *s_lambda = NIL, *s_macro = NIL;
  648. NODE *s_stdin = NIL, *s_stdout = NIL, *s_rtable = NIL;
  649. NODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
  650. NODE *s_car = NIL, *s_cdr = NIL, *s_nth = NIL;
  651. NODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL, *s_aref = NIL;
  652. NODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
  653. NODE *k_wspace = NIL, *k_const = NIL, *k_nmacro = NIL, *k_tmacro = NIL;
  654. NODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
  655. NODE *a_subr = NIL, *a_fsubr = NIL;
  656. NODE *a_list = NIL, *a_sym = NIL, *a_int = NIL, *a_float = NIL;
  657. NODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL, *a_vect;
  658. NODE *obarray = NIL, *s_unbound = NIL;
  659.  
  660. /* evaluation variables */
  661. NODE ***xlstack = NULL, ***xlstkbase = NULL, ***xlstktop = NULL;
  662. NODE *xlenv = NIL;
  663.  
  664. /* exception handling variables */
  665. CONTEXT *xlcontext = NULL;    /* current exception handler */
  666. NODE *xlvalue = NIL;        /* exception value */
  667.  
  668. /* debugging variables */
  669. int xldebug = 0;        /* debug level */
  670. int xltrace = -1;        /* trace stack pointer */
  671. NODE **trace_stack = NULL;    /* trace stack */
  672. int xlsample = 0;        /* control character sample rate */
  673.  
  674. /* gensym variables */
  675. char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
  676. int gsnumber = 1;        /* gensym number */
  677.  
  678. /* i/o variables */
  679. int prompt = TRUE;         /* prompt flag */
  680. int xlplevel = 0;        /* paren nesting level */
  681. int xlfsize = 0;        /* flat size of current print call */
  682.  
  683. /* dynamic memory variables */
  684. long total = 0L;        /* total memory in use */
  685. int anodes = 0;            /* number of nodes to allocate */
  686. int nnodes = 0;            /* number of nodes allocated */
  687. int nsegs = 0;            /* number of segments allocated */
  688. int nfree = 0;            /* number of nodes free */
  689. int gccalls = 0;        /* number of gc calls */
  690. struct segment *segs = NULL;    /* list of allocated segments */
  691. NODE *fnodes = NIL;        /* list of free nodes */
  692.  
  693. /* object programming variables */
  694. NODE *self = NIL, *class = NIL, *object = NIL;
  695. NODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
  696.  
  697. /* general purpose string buffer */
  698. char buf[STRMAX+1] = { 0 };
  699.  
  700. SHAR_EOF
  701. fi # end of overwriting check
  702. if test -f 'xlinit.c'
  703. then
  704.     echo shar: will not over-write existing file "'xlinit.c'"
  705. else
  706. cat << \SHAR_EOF > 'xlinit.c'
  707. /* xlinit.c - xlisp initialization module */
  708. /*    Copyright (c) 1985, by David Michael Betz
  709.     All Rights Reserved
  710.     Permission is granted for unrestricted non-commercial use    */
  711.  
  712. #include "xlisp.h"
  713.  
  714. /* external variables */
  715. extern NODE *true,*s_dot;
  716. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  717. extern NODE *s_lambda,*s_macro;
  718. extern NODE *s_stdin,*s_stdout;
  719. extern NODE *s_evalhook,*s_applyhook;
  720. extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
  721. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref,*s_eql;
  722. extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
  723. extern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
  724. extern NODE *a_subr,*a_fsubr;
  725. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
  726. extern struct fdef ftab[];
  727.  
  728. /* xlinit - xlisp initialization routine */
  729. xlinit()
  730. {
  731.     struct fdef *fptr;
  732.     NODE *sym;
  733.  
  734.     /* initialize xlisp (must be in this order) */
  735.     xlminit();    /* initialize xldmem.c */
  736.     xlsinit();    /* initialize xlsym.c */
  737.     xldinit();    /* initialize xldbug.c */
  738.     xloinit();    /* initialize xlobj.c */
  739.  
  740.     /* enter the builtin functions */
  741.     for (fptr = ftab; fptr->f_name; fptr++)
  742.     xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
  743.  
  744.     /* enter operating system specific functions */
  745.     osfinit();
  746.  
  747.     /* enter the 't' symbol */
  748.     true = xlsenter("T");
  749.     setvalue(true,true);
  750.  
  751.     /* enter some important symbols */
  752.     s_dot    = xlsenter(".");
  753.     s_quote    = xlsenter("QUOTE");
  754.     s_function    = xlsenter("FUNCTION");
  755.     s_bquote    = xlsenter("BACKQUOTE");
  756.     s_comma    = xlsenter("COMMA");
  757.     s_comat    = xlsenter("COMMA-AT");
  758.     s_lambda    = xlsenter("LAMBDA");
  759.     s_macro    = xlsenter("MACRO");
  760.     s_eql    = xlsenter("EQL");
  761.  
  762.     /* enter setf place specifiers */
  763.     s_car    = xlsenter("CAR");
  764.     s_cdr    = xlsenter("CDR");
  765.     s_nth    = xlsenter("NTH");
  766.     s_get    = xlsenter("GET");
  767.     s_svalue    = xlsenter("SYMBOL-VALUE");
  768.     s_splist    = xlsenter("SYMBOL-PLIST");
  769.     s_aref    = xlsenter("AREF");
  770.  
  771.     /* enter the readtable variable and keywords */
  772.     s_rtable    = xlsenter("*READTABLE*");
  773.     k_wspace    = xlsenter(":WHITE-SPACE");
  774.     k_const    = xlsenter(":CONSTITUENT");
  775.     k_nmacro    = xlsenter(":NMACRO");
  776.     k_tmacro    = xlsenter(":TMACRO");
  777.     xlrinit();
  778.  
  779.     /* enter parameter list keywords */
  780.     k_test    = xlsenter(":TEST");
  781.     k_tnot    = xlsenter(":TEST-NOT");
  782.  
  783.     /* enter lambda list keywords */
  784.     k_optional    = xlsenter("&OPTIONAL");
  785.     k_rest    = xlsenter("&REST");
  786.     k_aux    = xlsenter("&AUX");
  787.  
  788.     /* enter *standard-input* and *standard-output* */
  789.     s_stdin = xlsenter("*STANDARD-INPUT*");
  790.     setvalue(s_stdin,cvfile(stdin));
  791.     s_stdout = xlsenter("*STANDARD-OUTPUT*");
  792.     setvalue(s_stdout,cvfile(stdout));
  793.  
  794.     /* enter the eval and apply hook variables */
  795.     s_evalhook = xlsenter("*EVALHOOK*");
  796.     setvalue(s_evalhook,NIL);
  797.     s_applyhook = xlsenter("*APPLYHOOK*");
  798.     setvalue(s_applyhook,NIL);
  799.  
  800.     /* enter the error traceback and the error break enable flags */
  801.     s_tracenable = xlsenter("*TRACENABLE*");
  802.     setvalue(s_tracenable,NIL);
  803.     s_tlimit = xlsenter("*TRACELIMIT*");
  804.     setvalue(s_tlimit,NIL);
  805.     s_breakenable = xlsenter("*BREAKENABLE*");
  806.     setvalue(s_breakenable,true);
  807.  
  808.     /* enter a copyright notice into the oblist */
  809.     sym = xlsenter("**Copyright-1985-by-David-Betz**");
  810.     setvalue(sym,true);
  811.  
  812.     /* enter type names */
  813.     a_subr    = xlsenter(":SUBR");
  814.     a_fsubr    = xlsenter(":FSUBR");
  815.     a_list    = xlsenter(":CONS");
  816.     a_sym    = xlsenter(":SYMBOL");
  817.     a_int    = xlsenter(":FIXNUM");
  818.     a_float    = xlsenter(":FLONUM");
  819.     a_str    = xlsenter(":STRING");
  820.     a_obj    = xlsenter(":OBJECT");
  821.     a_fptr    = xlsenter(":FILE");
  822.     a_vect    = xlsenter(":ARRAY");
  823. }
  824.  
  825. SHAR_EOF
  826. fi # end of overwriting check
  827. if test -f 'xlio.c'
  828. then
  829.     echo shar: will not over-write existing file "'xlio.c'"
  830. else
  831. cat << \SHAR_EOF > 'xlio.c'
  832. /* xlio - xlisp i/o routines */
  833. /*    Copyright (c) 1985, by David Michael Betz
  834.     All Rights Reserved
  835.     Permission is granted for unrestricted non-commercial use    */
  836.  
  837. #include "xlisp.h"
  838.  
  839. #ifdef MEGAMAX
  840. overlay "io"
  841. #endif
  842.  
  843. /* external variables */
  844. extern NODE ***xlstack;
  845. extern NODE *s_stdin,*s_unbound;
  846. extern int xlfsize;
  847. extern int xlplevel;
  848. extern int xldebug;
  849. extern int prompt;
  850. extern char buf[];
  851.  
  852. /* xlgetc - get a character from a file or stream */
  853. int xlgetc(fptr)
  854.   NODE *fptr;
  855. {
  856.     NODE *lptr,*cptr;
  857.     FILE *fp;
  858.     int ch;
  859.  
  860.     /* check for input from nil */
  861.     if (fptr == NIL)
  862.     ch = EOF;
  863.  
  864.     /* otherwise, check for input from a stream */
  865.     else if (consp(fptr)) {
  866.     if ((lptr = car(fptr)) == NIL)
  867.         ch = EOF;
  868.     else {
  869.         if (!consp(lptr) ||
  870.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  871.         xlfail("bad stream");
  872.         if (rplaca(fptr,cdr(lptr)) == NIL)
  873.         rplacd(fptr,NIL);
  874.         ch = getfixnum(cptr);
  875.     }
  876.     }
  877.  
  878.     /* otherwise, check for a buffered file character */
  879.     else if (ch = getsavech(fptr))
  880.     setsavech(fptr,0);
  881.  
  882.     /* otherwise, get a new character */
  883.     else {
  884.  
  885.     /* get the file pointer */
  886.     fp = getfile(fptr);
  887.  
  888.     /* prompt if necessary */
  889.     if (prompt && fp == stdin) {
  890.  
  891.         /* print the debug level */
  892.         if (xldebug)
  893.         { sprintf(buf,"%d:",xldebug); stdputstr(buf); }
  894.  
  895.         /* print the nesting level */
  896.         if (xlplevel > 0)
  897.         { sprintf(buf,"%d",xlplevel); stdputstr(buf); }
  898.  
  899.         /* print the prompt */
  900.         stdputstr("> ");
  901.         prompt = FALSE;
  902.     }
  903.  
  904.     /* get the character */
  905.     if (((ch = osgetc(fp)) == '\n' || ch == EOF) && fp == stdin)
  906.         prompt = TRUE;
  907.     }
  908.  
  909.     /* return the character */
  910.     return (ch);
  911. }
  912.  
  913. /* docommand - create a nested MS-DOS shell */
  914. #ifdef SYSTEM
  915. docommand()
  916. {
  917.     stdputstr("\n[ creating a nested command processor ]\n");
  918.     system("COMMAND");
  919.     stdputstr("[ returning to XLISP ]\n");
  920. }
  921. #endif
  922.  
  923. /* xlpeek - peek at a character from a file or stream */
  924. int xlpeek(fptr)
  925.   NODE *fptr;
  926. {
  927.     NODE *lptr,*cptr;
  928.     int ch;
  929.  
  930.     /* check for input from nil */
  931.     if (fptr == NIL)
  932.     ch = EOF;
  933.  
  934.     /* otherwise, check for input from a stream */
  935.     else if (consp(fptr)) {
  936.     if ((lptr = car(fptr)) == NIL)
  937.         ch = EOF;
  938.     else {
  939.         if (!consp(lptr) ||
  940.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  941.         xlfail("bad stream");
  942.         ch = getfixnum(cptr);
  943.     }
  944.     }
  945.  
  946.     /* otherwise, get the next file character and save it */
  947.     else
  948.     setsavech(fptr,ch = xlgetc(fptr));
  949.  
  950.     /* return the character */
  951.     return (ch);
  952. }
  953.  
  954. /* xlputc - put a character to a file or stream */
  955. xlputc(fptr,ch)
  956.   NODE *fptr; int ch;
  957. {
  958.     NODE ***oldstk,*lptr;
  959.  
  960.     /* count the character */
  961.     xlfsize++;
  962.  
  963.     /* check for output to nil */
  964.     if (fptr == NIL)
  965.     ;
  966.  
  967.     /* otherwise, check for output to a stream */
  968.     else if (consp(fptr)) {
  969.     oldstk = xlsave(&lptr,(NODE **)NULL);
  970.     lptr = consa(NIL);
  971.     rplaca(lptr,cvfixnum((FIXNUM)ch));
  972.     if (cdr(fptr))
  973.         rplacd(cdr(fptr),lptr);
  974.     else
  975.         rplaca(fptr,lptr);
  976.     rplacd(fptr,lptr);
  977.     xlstack = oldstk;
  978.     }
  979.  
  980.     /* otherwise, output the character to a file */
  981.     else
  982.     osputc(ch,getfile(fptr));
  983. }
  984.  
  985. /* xlflush - flush the input buffer */
  986. int xlflush()
  987. {
  988.     if (!prompt)
  989.     while (xlgetc(getvalue(s_stdin)) != '\n')
  990.         ;
  991. }
  992.  
  993. SHAR_EOF
  994. fi # end of overwriting check
  995. if test -f 'xlisp.c'
  996. then
  997.     echo shar: will not over-write existing file "'xlisp.c'"
  998. else
  999. cat << \SHAR_EOF > 'xlisp.c'
  1000. /* xlisp - a small implementation of lisp with object-oriented programming */
  1001. /*    Copyright (c) 1985, by David Michael Betz
  1002.     All Rights Reserved
  1003.     Permission is granted for unrestricted non-commercial use    */
  1004.  
  1005. #include "xlisp.h"
  1006.  
  1007. /* define the banner line string */
  1008. #define BANNER    "XLISP version 1.6, Copyright (c) 1985, by David Betz"
  1009.  
  1010. /* external variables */
  1011. extern NODE *s_stdin,*s_stdout;
  1012. extern NODE *s_evalhook,*s_applyhook;
  1013. extern int xldebug;
  1014. extern NODE *true;
  1015.  
  1016. /* main - the main routine */
  1017. main(argc,argv)
  1018.   int argc; char *argv[];
  1019. {
  1020.     CONTEXT cntxt;
  1021.     NODE *expr;
  1022.     int i;
  1023.  
  1024.     /* initialize and print the banner line */
  1025.     osinit(BANNER);
  1026.  
  1027.     /* setup initialization error handler */
  1028.     xlbegin(&cntxt,CF_TOPLEVEL|CF_ERROR,(NODE *) 1);
  1029.     if (setjmp(cntxt.c_jmpbuf)) {
  1030.     printf("fatal initialization error\n");
  1031.     osfinish();
  1032.     exit(1);
  1033.     }
  1034.  
  1035.     /* initialize xlisp */
  1036.     xlinit();
  1037.     xlend(&cntxt);
  1038.  
  1039.     /* reset the error handler */
  1040.     xlbegin(&cntxt,CF_TOPLEVEL|CF_ERROR,true);
  1041.  
  1042.     /* load "init.lsp" */
  1043.     if (setjmp(cntxt.c_jmpbuf) == 0)
  1044.     xlload("init.lsp",FALSE,FALSE);
  1045.  
  1046.     /* load any files mentioned on the command line */
  1047. #ifndef MEGAMAX
  1048.     if (setjmp(cntxt.c_jmpbuf) == 0)
  1049.     for (i = 1; i < argc; i++)
  1050.         if (!xlload(argv[i],TRUE,FALSE))
  1051.         xlfail("can't load file");
  1052. #endif
  1053.  
  1054.     /* create a new stack frame */
  1055.     xlsave(&expr,(NODE **)NULL);
  1056.  
  1057.     /* main command processing loop */
  1058.     while (TRUE) {
  1059.  
  1060.     /* setup the error return */
  1061.     if (i = setjmp(cntxt.c_jmpbuf)) {
  1062.         if (i == CF_TOPLEVEL)
  1063.         stdputstr("[ back to the top level ]\n");
  1064.         setvalue(s_evalhook,NIL);
  1065.         setvalue(s_applyhook,NIL);
  1066.         xldebug = 0;
  1067.         xlflush();
  1068.     }
  1069.  
  1070.     /* read an expression */
  1071.     if (!xlread(getvalue(s_stdin),&expr,FALSE))
  1072.         break;
  1073.  
  1074.     /* evaluate the expression */
  1075.     expr = xleval(expr);
  1076.  
  1077.     /* print it */
  1078.     stdprint(expr);
  1079.     }
  1080.     xlend(&cntxt);
  1081.     osfinish ();
  1082.     exit (0);
  1083. }
  1084.  
  1085. /* stdprint - print to standard output */
  1086. stdprint(expr)
  1087.   NODE *expr;
  1088. {
  1089.     xlprint(getvalue(s_stdout),expr,TRUE);
  1090.     xlterpri(getvalue(s_stdout));
  1091. }
  1092.  
  1093. /* stdputstr - print a string to standard output */
  1094. stdputstr(str)
  1095.   char *str;
  1096. {
  1097.     xlputstr(getvalue(s_stdout),str);
  1098. }
  1099.  
  1100. SHAR_EOF
  1101. fi # end of overwriting check
  1102. if test -f 'xljump.c'
  1103. then
  1104.     echo shar: will not over-write existing file "'xljump.c'"
  1105. else
  1106. cat << \SHAR_EOF > 'xljump.c'
  1107. /* xljump - execution context routines */
  1108. /*    Copyright (c) 1985, by David Michael Betz
  1109.     All Rights Reserved
  1110.     Permission is granted for unrestricted non-commercial use    */
  1111.  
  1112. #include "xlisp.h"
  1113.  
  1114. /* external variables */
  1115. extern CONTEXT *xlcontext;
  1116. extern NODE *xlvalue;
  1117. extern NODE ***xlstack,*xlenv;
  1118. extern int xltrace,xldebug;
  1119.  
  1120. /* xlbegin - beginning of an execution context */
  1121. xlbegin(cptr,flags,expr)
  1122.   CONTEXT *cptr; int flags; NODE *expr;
  1123. {
  1124.     cptr->c_flags = flags;
  1125.     cptr->c_expr = expr;
  1126.     cptr->c_xlstack = xlstack;
  1127.     cptr->c_xlenv = xlenv;
  1128.     cptr->c_xltrace = xltrace;
  1129.     cptr->c_xlcontext = xlcontext;
  1130.     xlcontext = cptr;
  1131. }
  1132.  
  1133. /* xlend - end of an execution context */
  1134. xlend(cptr)
  1135.   CONTEXT *cptr;
  1136. {
  1137.     xlcontext = cptr->c_xlcontext;
  1138. }
  1139.  
  1140. /* xljump - jump to a saved execution context */
  1141. xljump(cptr,type,val)
  1142.   CONTEXT *cptr; int type; NODE *val;
  1143. {
  1144.     /* restore the state */
  1145.     xlcontext = cptr;
  1146.     xlstack = xlcontext->c_xlstack;
  1147.     xlenv = xlcontext->c_xlenv;
  1148.     xltrace = xlcontext->c_xltrace;
  1149.     xlvalue = val;
  1150.  
  1151.     /* call the handler */
  1152.     longjmp(xlcontext->c_jmpbuf,type);
  1153. }
  1154.  
  1155. /* xltoplevel - go back to the top level */
  1156. xltoplevel()
  1157. {
  1158.     findtarget(CF_TOPLEVEL,"no top level");
  1159. }
  1160.  
  1161. /* xlcleanup - clean-up after an error */
  1162. xlcleanup()
  1163. {
  1164.     findtarget(CF_CLEANUP,"not in a break loop");
  1165. }
  1166.  
  1167. /* xlcontinue - continue from an error */
  1168. xlcontinue()
  1169. {
  1170.     findtarget(CF_CONTINUE,"not in a break loop");
  1171. }
  1172.  
  1173. /* xlgo - go to a label */
  1174. xlgo(label)
  1175.   NODE *label;
  1176. {
  1177.     CONTEXT *cptr;
  1178.     NODE *p;
  1179.  
  1180.     /* find a tagbody context */
  1181.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1182.     if (cptr->c_flags & CF_GO)
  1183.         for (p = cptr->c_expr; consp(p); p = cdr(p))
  1184.         if (car(p) == label)
  1185.             xljump(cptr,CF_GO,p);
  1186.     xlfail("no target for GO");
  1187. }
  1188.  
  1189. /* xlreturn - return from a block */
  1190. xlreturn(val)
  1191.   NODE *val;
  1192. {
  1193.     CONTEXT *cptr;
  1194.  
  1195.     /* find a block context */
  1196.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1197.     if (cptr->c_flags & CF_RETURN)
  1198.         xljump(cptr,CF_RETURN,val);
  1199.     xlfail("no target for RETURN");
  1200. }
  1201.  
  1202. /* xlthrow - throw to a catch */
  1203. xlthrow(tag,val)
  1204.   NODE *tag,*val;
  1205. {
  1206.     CONTEXT *cptr;
  1207.  
  1208.     /* find a catch context */
  1209.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1210.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  1211.         xljump(cptr,CF_THROW,val);
  1212.     xlfail("no target for THROW");
  1213. }
  1214.  
  1215. /* xlsignal - signal an error */
  1216. xlsignal(emsg,arg)
  1217.   char *emsg; NODE *arg;
  1218. {
  1219.     CONTEXT *cptr;
  1220.  
  1221.     /* find an error catcher */
  1222.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1223.     if (cptr->c_flags & CF_ERROR) {
  1224.         if (cptr->c_expr && emsg)
  1225.         xlerrprint("error",NULL,emsg,arg);
  1226.         xljump(cptr,CF_ERROR,NIL);
  1227.     }
  1228.     xlfail("no target for error");
  1229. }
  1230.  
  1231. /* findtarget - find a target context frame */
  1232. LOCAL findtarget(flag,error)
  1233.   int flag; char *error;
  1234. {
  1235.     CONTEXT *cptr;
  1236.  
  1237.     /* find a block context */
  1238.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1239.     if (cptr->c_flags & flag)
  1240.         xljump(cptr,flag,NIL);
  1241.     xlabort(error);
  1242. }
  1243.  
  1244. SHAR_EOF
  1245. fi # end of overwriting check
  1246. if test -f 'xllist.c'
  1247. then
  1248.     echo shar: will not over-write existing file "'xllist.c'"
  1249. else
  1250. cat << \SHAR_EOF > 'xllist.c'
  1251. /* xllist - xlisp built-in list functions */
  1252. /*    Copyright (c) 1985, by David Michael Betz
  1253.     All Rights Reserved
  1254.     Permission is granted for unrestricted non-commercial use    */
  1255.  
  1256. #include "xlisp.h"
  1257.  
  1258. #ifdef MEGAMAX
  1259. overlay "overflow"
  1260. #endif
  1261.  
  1262. /* external variables */
  1263. extern NODE ***xlstack;
  1264. extern NODE *s_unbound;
  1265. extern NODE *true;
  1266.  
  1267. /* external routines */
  1268. extern int eq(),eql(),equal();
  1269.  
  1270. /* forward declarations */
  1271. FORWARD NODE *cxr();
  1272. FORWARD NODE *nth(),*assoc();
  1273. FORWARD NODE *subst(),*sublis(),*map();
  1274. FORWARD NODE *cequal();
  1275.  
  1276. /* cxr functions */
  1277. NODE *xcar(args) NODE *args; { return (cxr(args,"a")); }
  1278. NODE *xcdr(args) NODE *args; { return (cxr(args,"d")); }
  1279.  
  1280. /* cxxr functions */
  1281. NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
  1282. NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
  1283. NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
  1284. NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }
  1285.  
  1286. /* cxxxr functions */
  1287. NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
  1288. NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
  1289. NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
  1290. NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
  1291. NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
  1292. NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
  1293. NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
  1294. NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }
  1295.  
  1296. /* cxxxxr functions */
  1297. NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
  1298. NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
  1299. NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
  1300. NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
  1301. NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
  1302. NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
  1303. NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
  1304. NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
  1305. NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
  1306. NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
  1307. NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
  1308. NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
  1309. NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
  1310. NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
  1311. NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
  1312. NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }
  1313.  
  1314. /* cxr - common car/cdr routine */
  1315. LOCAL NODE *cxr(args,adstr)
  1316.   NODE *args; char *adstr;
  1317. {
  1318.     NODE *list;
  1319.  
  1320.     /* get the list */
  1321.     list = xlmatch(LIST,&args);
  1322.     xllastarg(args);
  1323.  
  1324.     /* perform the car/cdr operations */
  1325.     while (*adstr && consp(list))
  1326.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  1327.  
  1328.     /* make sure the operation succeeded */
  1329.     if (*adstr && list)
  1330.     xlfail("bad argument");
  1331.  
  1332.     /* return the result */
  1333.     return (list);
  1334. }
  1335.  
  1336. /* xcons - construct a new list cell */
  1337. NODE *xcons(args)
  1338.   NODE *args;
  1339. {
  1340.     NODE *arg1,*arg2;
  1341.  
  1342.     /* get the two arguments */
  1343.     arg1 = xlarg(&args);
  1344.     arg2 = xlarg(&args);
  1345.     xllastarg(args);
  1346.  
  1347.     /* construct a new list element */
  1348.     return (cons(arg1,arg2));
  1349. }
  1350.  
  1351. /* xlist - built a list of the arguments */
  1352. NODE *xlist(args)
  1353.   NODE *args;
  1354. {
  1355.     NODE ***oldstk,*arg,*list,*val,*last;
  1356.     NODE *lptr = NIL;
  1357.  
  1358.     /* create a new stack frame */
  1359.     oldstk = xlsave(&arg,&list,&val,(NODE **)NULL);
  1360.  
  1361.     /* initialize */
  1362.     arg = args;
  1363.  
  1364.     /* evaluate and append each argument */
  1365.     for (last = NIL; arg; last = lptr) {
  1366.  
  1367.     /* evaluate the next argument */
  1368.     val = xlarg(&arg);
  1369.  
  1370.     /* append this argument to the end of the list */
  1371.     lptr = consa(val);
  1372.     if (last == NIL)
  1373.         list = lptr;
  1374.     else
  1375.         rplacd(last,lptr);
  1376.     }
  1377.  
  1378.     /* restore the previous stack frame */
  1379.     xlstack = oldstk;
  1380.  
  1381.     /* return the list */
  1382.     return (list);
  1383. }
  1384.  
  1385. /* xappend - built-in function append */
  1386. NODE *xappend(args)
  1387.   NODE *args;
  1388. {
  1389.     NODE ***oldstk,*arg,*list,*last,*val,*lptr;
  1390.  
  1391.     /* create a new stack frame */
  1392.     oldstk = xlsave(&arg,&list,&last,&val,(NODE **)NULL);
  1393.  
  1394.     /* initialize */
  1395.     arg = args;
  1396.  
  1397.     /* evaluate and append each argument */
  1398.     while (arg) {
  1399.  
  1400.     /* evaluate the next argument */
  1401.     list = xlmatch(LIST,&arg);
  1402.  
  1403.     /* append each element of this list to the result list */
  1404.     while (consp(list)) {
  1405.  
  1406.         /* append this element */
  1407.         lptr = consa(car(list));
  1408.         if (last == NIL)
  1409.         val = lptr;
  1410.         else
  1411.         rplacd(last,lptr);
  1412.  
  1413.         /* save the new last element */
  1414.         last = lptr;
  1415.  
  1416.         /* move to the next element */
  1417.         list = cdr(list);
  1418.     }
  1419.     }
  1420.  
  1421.     /* restore previous stack frame */
  1422.     xlstack = oldstk;
  1423.  
  1424.     /* return the list */
  1425.     return (val);
  1426. }
  1427.  
  1428. /* xreverse - built-in function reverse */
  1429. NODE *xreverse(args)
  1430.   NODE *args;
  1431. {
  1432.     NODE ***oldstk,*list,*val;
  1433.  
  1434.     /* create a new stack frame */
  1435.     oldstk = xlsave(&list,&val,(NODE **)NULL);
  1436.  
  1437.     /* get the list to reverse */
  1438.     list = xlmatch(LIST,&args);
  1439.     xllastarg(args);
  1440.  
  1441.     /* append each element of this list to the result list */
  1442.     while (consp(list)) {
  1443.  
  1444.     /* append this element */
  1445.     val = cons(car(list),val);
  1446.  
  1447.     /* move to the next element */
  1448.     list = cdr(list);
  1449.     }
  1450.  
  1451.     /* restore previous stack frame */
  1452.     xlstack = oldstk;
  1453.  
  1454.     /* return the list */
  1455.     return (val);
  1456. }
  1457.  
  1458. /* xlast - return the last cons of a list */
  1459. NODE *xlast(args)
  1460.   NODE *args;
  1461. {
  1462.     NODE *list;
  1463.  
  1464.     /* get the list */
  1465.     list = xlmatch(LIST,&args);
  1466.     xllastarg(args);
  1467.  
  1468.     /* find the last cons */
  1469.     while (consp(list) && cdr(list))
  1470.     list = cdr(list);
  1471.  
  1472.     /* return the last element */
  1473.     return (list);
  1474. }
  1475.  
  1476. /* xmember - built-in function 'member' */
  1477. NODE *xmember(args)
  1478.   NODE *args;
  1479. {
  1480.     NODE ***oldstk,*x,*list,*fcn,*val;
  1481.     int tresult;
  1482.  
  1483.     /* create a new stack frame */
  1484.     oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
  1485.  
  1486.     /* get the expression to look for and the list */
  1487.     x = xlarg(&args);
  1488.     list = xlmatch(LIST,&args);
  1489.     xltest(&fcn,&tresult,&args);
  1490.     xllastarg(args);
  1491.  
  1492.     /* look for the expression */
  1493.     for (val = NIL; consp(list); list = cdr(list))
  1494.     if (dotest(x,car(list),fcn) == tresult) {
  1495.         val = list;
  1496.         break;
  1497.     }
  1498.  
  1499.     /* restore the previous stack frame */
  1500.     xlstack = oldstk;
  1501.  
  1502.     /* return the result */
  1503.     return (val);
  1504. }
  1505.  
  1506. /* xassoc - built-in function 'assoc' */
  1507. NODE *xassoc(args)
  1508.   NODE *args;
  1509. {
  1510.     NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
  1511.     int tresult;
  1512.  
  1513.     /* create a new stack frame */
  1514.     oldstk = xlsave(&x,&alist,&fcn,(NODE **)NULL);
  1515.  
  1516.     /* get the expression to look for and the association list */
  1517.     x = xlarg(&args);
  1518.     alist = xlmatch(LIST,&args);
  1519.     xltest(&fcn,&tresult,&args);
  1520.     xllastarg(args);
  1521.  
  1522.     /* look for the expression */
  1523.     for (val = NIL; consp(alist); alist = cdr(alist))
  1524.     if ((pair = car(alist)) && consp(pair))
  1525.         if (dotest(x,car(pair),fcn) == tresult) {
  1526.         val = pair;
  1527.         break;
  1528.         }
  1529.  
  1530.     /* restore the previous stack frame */
  1531.     xlstack = oldstk;
  1532.  
  1533.     /* return the result */
  1534.     return (val);
  1535. }
  1536.  
  1537. /* xsubst - substitute one expression for another */
  1538. NODE *xsubst(args)
  1539.   NODE *args;
  1540. {
  1541.     NODE ***oldstk,*to,*from,*expr,*fcn,*val;
  1542.     int tresult;
  1543.  
  1544.     /* create a new stack frame */
  1545.     oldstk = xlsave(&to,&from,&expr,&fcn,(NODE **)NULL);
  1546.  
  1547.     /* get the to value, the from value and the expression */
  1548.     to = xlarg(&args);
  1549.     from = xlarg(&args);
  1550.     expr = xlarg(&args);
  1551.     xltest(&fcn,&tresult,&args);
  1552.     xllastarg(args);
  1553.  
  1554.     /* do the substitution */
  1555.     val = subst(to,from,expr,fcn,tresult);
  1556.  
  1557.     /* restore the previous stack frame */
  1558.     xlstack = oldstk;
  1559.  
  1560.     /* return the result */
  1561.     return (val);
  1562. }
  1563.  
  1564. /* subst - substitute one expression for another */
  1565. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  1566.   NODE *to,*from,*expr,*fcn; int tresult;
  1567. {
  1568.     NODE ***oldstk,*carval,*cdrval,*val;
  1569.  
  1570.     if (dotest(expr,from,fcn) == tresult)
  1571.     val = to;
  1572.     else if (consp(expr)) {
  1573.     oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
  1574.     carval = subst(to,from,car(expr),fcn,tresult);
  1575.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  1576.     val = cons(carval,cdrval);
  1577.     xlstack = oldstk;
  1578.     }
  1579.     else
  1580.     val = expr;
  1581.     return (val);
  1582. }
  1583.  
  1584. /* xsublis - substitute using an association list */
  1585. NODE *xsublis(args)
  1586.   NODE *args;
  1587. {
  1588.     NODE ***oldstk,*alist,*expr,*fcn,*val;
  1589.     int tresult;
  1590.  
  1591.     /* create a new stack frame */
  1592.     oldstk = xlsave(&alist,&expr,&fcn,(NODE **)NULL);
  1593.  
  1594.     /* get the assocation list and the expression */
  1595.     alist = xlmatch(LIST,&args);
  1596.     expr = xlarg(&args);
  1597.     xltest(&fcn,&tresult,&args);
  1598.     xllastarg(args);
  1599.  
  1600.     /* do the substitution */
  1601.     val = sublis(alist,expr,fcn,tresult);
  1602.  
  1603.     /* restore the previous stack frame */
  1604.     xlstack = oldstk;
  1605.  
  1606.     /* return the result */
  1607.     return (val);
  1608. }
  1609.  
  1610. /* sublis - substitute using an association list */
  1611. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  1612.   NODE *alist,*expr,*fcn; int tresult;
  1613. {
  1614.     NODE ***oldstk,*carval,*cdrval,*val;
  1615.  
  1616.     if (val = assoc(expr,alist,fcn,tresult))
  1617.     val = cdr(val);
  1618.     else if (consp(expr)) {
  1619.     oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
  1620.     carval = sublis(alist,car(expr),fcn,tresult);
  1621.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  1622.     val = cons(carval,cdrval);
  1623.     xlstack = oldstk;
  1624.     }
  1625.     else
  1626.     val = expr;
  1627.     return (val);
  1628. }
  1629.  
  1630. /* assoc - find a pair in an association list */
  1631. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  1632.   NODE *expr,*alist,*fcn; int tresult;
  1633. {
  1634.     NODE *pair;
  1635.  
  1636.     for (; consp(alist); alist = cdr(alist))
  1637.     if ((pair = car(alist)) && consp(pair))
  1638.         if (dotest(expr,car(pair),fcn) == tresult)
  1639.         return (pair);
  1640.     return (NIL);
  1641. }
  1642.  
  1643. /* xremove - built-in function 'remove' */
  1644. NODE *xremove(args)
  1645.   NODE *args;
  1646. {
  1647.     NODE ***oldstk,*x,*list,*fcn,*val,*p;
  1648.     NODE *last = NIL;
  1649.     int tresult;
  1650.  
  1651.     /* create a new stack frame */
  1652.     oldstk = xlsave(&x,&list,&fcn,&val,(NODE **)NULL);
  1653.  
  1654.     /* get the expression to remove and the list */
  1655.     x = xlarg(&args);
  1656.     list = xlmatch(LIST,&args);
  1657.     xltest(&fcn,&tresult,&args);
  1658.     xllastarg(args);
  1659.  
  1660.     /* remove matches */
  1661.     while (consp(list)) {
  1662.  
  1663.     /* check to see if this element should be deleted */
  1664.     if (dotest(x,car(list),fcn) != tresult) {
  1665.         p = consa(car(list));
  1666.         if (val) rplacd(last,p);
  1667.         else val = p;
  1668.         last = p;
  1669.     }
  1670.  
  1671.     /* move to the next element */
  1672.     list = cdr(list);
  1673.     }
  1674.  
  1675.     /* restore the previous stack frame */
  1676.     xlstack = oldstk;
  1677.  
  1678.     /* return the updated list */
  1679.     return (val);
  1680. }
  1681.  
  1682. /* dotest - call a test function */
  1683. int dotest(arg1,arg2,fcn)
  1684.   NODE *arg1,*arg2,*fcn;
  1685. {
  1686.     NODE ***oldstk,*args,*val;
  1687.  
  1688.     /* create a new stack frame */
  1689.     oldstk = xlsave(&args,(NODE **)NULL);
  1690.  
  1691.     /* build an argument list */
  1692.     args = consa(arg1);
  1693.     rplacd(args,consa(arg2));
  1694.  
  1695.     /* apply the test function */
  1696.     val = xlapply(fcn,args);
  1697.  
  1698.     /* restore the previous stack frame */
  1699.     xlstack = oldstk;
  1700.  
  1701.     /* return the result of the test */
  1702.     return (val != NIL);
  1703. }
  1704.  
  1705. /* xnth - return the nth element of a list */
  1706. NODE *xnth(args)
  1707.   NODE *args;
  1708. {
  1709.     return (nth(args,TRUE));
  1710. }
  1711.  
  1712. /* xnthcdr - return the nth cdr of a list */
  1713. NODE *xnthcdr(args)
  1714.   NODE *args;
  1715. {
  1716.     return (nth(args,FALSE));
  1717. }
  1718.  
  1719. /* nth - internal nth function */
  1720. LOCAL NODE *nth(args,carflag)
  1721.   NODE *args; int carflag;
  1722. {
  1723.     NODE *list;
  1724.     int n;
  1725.  
  1726.     /* get n and the list */
  1727.     if ((n = getfixnum(xlmatch(INT,&args))) < 0)
  1728.     xlfail("bad argument");
  1729.     if ((list = xlmatch(LIST,&args)) == NIL)
  1730.     xlfail("bad argument");
  1731.     xllastarg(args);
  1732.  
  1733.     /* find the nth element */
  1734.     while (consp(list) && n--)
  1735.     list = cdr(list);
  1736.  
  1737.     /* return the list beginning at the nth element */
  1738.     return (carflag && consp(list) ? car(list) : list);
  1739. }
  1740.  
  1741. /* xlength - return the length of a list or string */
  1742. NODE *xlength(args)
  1743.   NODE *args;
  1744. {
  1745.     NODE *arg;
  1746.     int n;
  1747.  
  1748.     /* get the list or string */
  1749.     arg = xlarg(&args);
  1750.     xllastarg(args);
  1751.  
  1752.     /* find the length of a list */
  1753.     if (listp(arg))
  1754.     for (n = 0; consp(arg); n++)
  1755.         arg = cdr(arg);
  1756.  
  1757.     /* find the length of a string */
  1758.     else if (stringp(arg))
  1759.     n = strlen(getstring(arg));
  1760.  
  1761.     /* find the length of a vector */
  1762.     else if (vectorp(arg))
  1763.     n = getsize(arg);
  1764.  
  1765.     /* otherwise, bad argument type */
  1766.     else
  1767.     xlerror("bad argument type",arg);
  1768.  
  1769.     /* return the length */
  1770.     return (cvfixnum((FIXNUM)n));
  1771. }
  1772.  
  1773. /* xmapc - built-in function 'mapc' */
  1774. NODE *xmapc(args)
  1775.   NODE *args;
  1776. {
  1777.     return (map(args,TRUE,FALSE));
  1778. }
  1779.  
  1780. /* xmapcar - built-in function 'mapcar' */
  1781. NODE *xmapcar(args)
  1782.   NODE *args;
  1783. {
  1784.     return (map(args,TRUE,TRUE));
  1785. }
  1786.  
  1787. /* xmapl - built-in function 'mapl' */
  1788. NODE *xmapl(args)
  1789.   NODE *args;
  1790. {
  1791.     return (map(args,FALSE,FALSE));
  1792. }
  1793.  
  1794. /* xmaplist - built-in function 'maplist' */
  1795. NODE *xmaplist(args)
  1796.   NODE *args;
  1797. {
  1798.     return (map(args,FALSE,TRUE));
  1799. }
  1800.  
  1801. /* map - internal mapping function */
  1802. LOCAL NODE *map(args,carflag,valflag)
  1803.   NODE *args; int carflag,valflag;
  1804. {
  1805.     NODE ***oldstk,*fcn,*lists,*arglist,*val,*p,*x,*y;
  1806.     NODE *last = NIL;
  1807.  
  1808.     /* create a new stack frame */
  1809.     oldstk = xlsave(&fcn,&lists,&arglist,&val,(NODE **)NULL);
  1810.  
  1811.     /* get the function to apply and the first list */
  1812.     fcn = xlarg(&args);
  1813.     lists = xlmatch(LIST,&args);
  1814.  
  1815.     /* save the first list if not saving function values */
  1816.     if (!valflag)
  1817.     val = lists;
  1818.  
  1819.     /* set up the list of argument lists */
  1820.     lists = consa(lists);
  1821.  
  1822.     /* get the remaining argument lists */
  1823.     while (args) {
  1824.     lists = consd(lists);
  1825.     rplaca(lists,xlmatch(LIST,&args));
  1826.     }
  1827.  
  1828.     /* if the function is a symbol, get its value */
  1829.     if (symbolp(fcn))
  1830.     fcn = xleval(fcn);
  1831.  
  1832.     /* loop through each of the argument lists */
  1833.     for (;;) {
  1834.  
  1835.     /* build an argument list from the sublists */
  1836.     arglist = NIL;
  1837.     for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
  1838.         arglist = consd(arglist);
  1839.         rplaca(arglist,carflag ? car(y) : y);
  1840.         rplaca(x,cdr(y));
  1841.     }
  1842.  
  1843.     /* quit if any of the lists were empty */
  1844.     if (x) break;
  1845.  
  1846.     /* apply the function to the arguments */
  1847.     if (valflag) {
  1848.         p = consa(NIL);
  1849.         if (val) rplacd(last,p);
  1850.         else val = p;
  1851.         rplaca(p,xlapply(fcn,arglist));
  1852.         last = p;
  1853.     }
  1854.     else
  1855.         xlapply(fcn,arglist);
  1856.     }
  1857.  
  1858.     /* restore the previous stack frame */
  1859.     xlstack = oldstk;
  1860.  
  1861.     /* return the last test expression value */
  1862.     return (val);
  1863. }
  1864.  
  1865. /* xrplca - replace the car of a list node */
  1866. NODE *xrplca(args)
  1867.   NODE *args;
  1868. {
  1869.     NODE *list,*newcar;
  1870.  
  1871.     /* get the list and the new car */
  1872.     if ((list = xlmatch(LIST,&args)) == NIL)
  1873.     xlfail("bad argument");
  1874.     newcar = xlarg(&args);
  1875.     xllastarg(args);
  1876.  
  1877.     /* replace the car */
  1878.     rplaca(list,newcar);
  1879.  
  1880.     /* return the list node that was modified */
  1881.     return (list);
  1882. }
  1883.  
  1884. /* xrplcd - replace the cdr of a list node */
  1885. NODE *xrplcd(args)
  1886.   NODE *args;
  1887. {
  1888.     NODE *list,*newcdr;
  1889.  
  1890.     /* get the list and the new cdr */
  1891.     if ((list = xlmatch(LIST,&args)) == NIL)
  1892.     xlfail("bad argument");
  1893.     newcdr = xlarg(&args);
  1894.     xllastarg(args);
  1895.  
  1896.     /* replace the cdr */
  1897.     rplacd(list,newcdr);
  1898.  
  1899.     /* return the list node that was modified */
  1900.     return (list);
  1901. }
  1902.  
  1903. /* xnconc - destructively append lists */
  1904. NODE *xnconc(args)
  1905.   NODE *args;
  1906. {
  1907.     NODE *list,*val;
  1908.     NODE *last = NIL;
  1909.  
  1910.     /* concatenate each argument */
  1911.     for (val = NIL; args; ) {
  1912.  
  1913.     /* concatenate this list */
  1914.     if (list = xlmatch(LIST,&args)) {
  1915.  
  1916.         /* check for this being the first non-empty list */
  1917.         if (val)
  1918.         rplacd(last,list);
  1919.         else
  1920.         val = list;
  1921.  
  1922.         /* find the end of the list */
  1923.         while (consp(cdr(list)))
  1924.         list = cdr(list);
  1925.  
  1926.         /* save the new last element */
  1927.         last = list;
  1928.     }
  1929.     }
  1930.  
  1931.     /* return the list */
  1932.     return (val);
  1933. }
  1934.  
  1935. /* xdelete - built-in function 'delete' */
  1936. NODE *xdelete(args)
  1937.   NODE *args;
  1938. {
  1939.     NODE ***oldstk,*x,*list,*fcn,*last,*val;
  1940.     int tresult;
  1941.  
  1942.     /* create a new stack frame */
  1943.     oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
  1944.  
  1945.     /* get the expression to delete and the list */
  1946.     x = xlarg(&args);
  1947.     list = xlmatch(LIST,&args);
  1948.     xltest(&fcn,&tresult,&args);
  1949.     xllastarg(args);
  1950.  
  1951.     /* delete leading matches */
  1952.     while (consp(list)) {
  1953.     if (dotest(x,car(list),fcn) != tresult)
  1954.         break;
  1955.     list = cdr(list);
  1956.     }
  1957.     val = last = list;
  1958.  
  1959.     /* delete embedded matches */
  1960.     if (consp(list)) {
  1961.  
  1962.     /* skip the first non-matching element */
  1963.     list = cdr(list);
  1964.  
  1965.     /* look for embedded matches */
  1966.     while (consp(list)) {
  1967.  
  1968.         /* check to see if this element should be deleted */
  1969.         if (dotest(x,car(list),fcn) == tresult)
  1970.         rplacd(last,cdr(list));
  1971.         else
  1972.         last = list;
  1973.  
  1974.         /* move to the next element */
  1975.         list = cdr(list);
  1976.      }
  1977.     }
  1978.  
  1979.     /* restore the previous stack frame */
  1980.     xlstack = oldstk;
  1981.  
  1982.     /* return the updated list */
  1983.     return (val);
  1984. }
  1985.  
  1986. /* xatom - is this an atom? */
  1987. NODE *xatom(args)
  1988.   NODE *args;
  1989. {
  1990.     NODE *arg;
  1991.     arg = xlarg(&args);
  1992.     xllastarg(args);
  1993.     return (atom(arg) ? true : NIL);
  1994. }
  1995.  
  1996. /* xsymbolp - is this an symbol? */
  1997. NODE *xsymbolp(args)
  1998.   NODE *args;
  1999. {
  2000.     NODE *arg;
  2001.     arg = xlarg(&args);
  2002.     xllastarg(args);
  2003.     return (arg == NIL || symbolp(arg) ? true : NIL);
  2004. }
  2005.  
  2006. /* xnumberp - is this a number? */
  2007. NODE *xnumberp(args)
  2008.   NODE *args;
  2009. {
  2010.     NODE *arg;
  2011.     arg = xlarg(&args);
  2012.     xllastarg(args);
  2013.     return (fixp(arg) || floatp(arg) ? true : NIL);
  2014. }
  2015.  
  2016. /* xboundp - is this a value bound to this symbol? */
  2017. NODE *xboundp(args)
  2018.   NODE *args;
  2019. {
  2020.     NODE *sym;
  2021.     sym = xlmatch(SYM,&args);
  2022.     xllastarg(args);
  2023.     return (getvalue(sym) == s_unbound ? NIL : true);
  2024. }
  2025.  
  2026. /* xnull - is this null? */
  2027. NODE *xnull(args)
  2028.   NODE *args;
  2029. {
  2030.     NODE *arg;
  2031.     arg = xlarg(&args);
  2032.     xllastarg(args);
  2033.     return (null(arg) ? true : NIL);
  2034. }
  2035.  
  2036. /* xlistp - is this a list? */
  2037. NODE *xlistp(args)
  2038.   NODE *args;
  2039. {
  2040.     NODE *arg;
  2041.     arg = xlarg(&args);
  2042.     xllastarg(args);
  2043.     return (listp(arg) ? true : NIL);
  2044. }
  2045.  
  2046. /* xconsp - is this a cons? */
  2047. NODE *xconsp(args)
  2048.   NODE *args;
  2049. {
  2050.     NODE *arg;
  2051.     arg = xlarg(&args);
  2052.     xllastarg(args);
  2053.     return (consp(arg) ? true : NIL);
  2054. }
  2055.  
  2056. /* xeq - are these equal? */
  2057. NODE *xeq(args)
  2058.   NODE *args;
  2059. {
  2060.     return (cequal(args,eq));
  2061. }
  2062.  
  2063. /* xeql - are these equal? */
  2064. NODE *xeql(args)
  2065.   NODE *args;
  2066. {
  2067.     return (cequal(args,eql));
  2068. }
  2069.  
  2070. /* xequal - are these equal? */
  2071. NODE *xequal(args)
  2072.   NODE *args;
  2073. {
  2074.     return (cequal(args,equal));
  2075. }
  2076.  
  2077. /* cequal - common eq/eql/equal function */
  2078. LOCAL NODE *cequal(args,fcn)
  2079.   NODE *args; int (*fcn)();
  2080. {
  2081.     NODE *arg1,*arg2;
  2082.  
  2083.     /* get the two arguments */
  2084.     arg1 = xlarg(&args);
  2085.     arg2 = xlarg(&args);
  2086.     xllastarg(args);
  2087.  
  2088.     /* compare the arguments */
  2089.     return ((*fcn)(arg1,arg2) ? true : NIL);
  2090. }
  2091.  
  2092. SHAR_EOF
  2093. fi # end of overwriting check
  2094. if test -f 'xlmath.c'
  2095. then
  2096.     echo shar: will not over-write existing file "'xlmath.c'"
  2097. else
  2098. cat << \SHAR_EOF > 'xlmath.c'
  2099. /* xlmath - xlisp builtin arithmetic functions */
  2100. /*    Copyright (c) 1985, by David Michael Betz
  2101.     All Rights Reserved
  2102.     Permission is granted for unrestricted non-commercial use    */
  2103.  
  2104. #ifdef MEGAMAX
  2105. #include <fmath.h>
  2106. overlay "math"
  2107. #else
  2108. #include <math.h>
  2109. #endif
  2110.  
  2111. /*
  2112.  * Lattice's math.h include declarations for fabs, so must come before
  2113.  * xlisp.h
  2114.  */
  2115.  
  2116. #include "xlisp.h"
  2117.  
  2118. /* external variables */
  2119. extern NODE *true;
  2120.  
  2121. /* forward declarations */
  2122. FORWARD NODE *unary();
  2123. FORWARD NODE *binary();
  2124. FORWARD NODE *predicate();
  2125. FORWARD NODE *compare();
  2126.  
  2127. /* xadd - builtin function for addition */
  2128. NODE *xadd(args)
  2129.   NODE *args;
  2130. {
  2131.     return (binary(args,'+'));
  2132. }
  2133.  
  2134. /* xsub - builtin function for subtraction */
  2135. NODE *xsub(args)
  2136.   NODE *args;
  2137. {
  2138.     return (binary(args,'-'));
  2139. }
  2140.  
  2141. /* xmul - builtin function for multiplication */
  2142. NODE *xmul(args)
  2143.   NODE *args;
  2144. {
  2145.     return (binary(args,'*'));
  2146. }
  2147.  
  2148. /* xdiv - builtin function for division */
  2149. NODE *xdiv(args)
  2150.   NODE *args;
  2151. {
  2152.     return (binary(args,'/'));
  2153. }
  2154.  
  2155. /* xrem - builtin function for remainder */
  2156. NODE *xrem(args)
  2157.   NODE *args;
  2158. {
  2159.     return (binary(args,'%'));
  2160. }
  2161.  
  2162. /* xmin - builtin function for minimum */
  2163. NODE *xmin(args)
  2164.   NODE *args;
  2165. {
  2166.     return (binary(args,'m'));
  2167. }
  2168.  
  2169. /* xmax - builtin function for maximum */
  2170. NODE *xmax(args)
  2171.   NODE *args;
  2172. {
  2173.     return (binary(args,'M'));
  2174. }
  2175.  
  2176. /* xexpt - built-in function 'expt' */
  2177. NODE *xexpt(args)
  2178.   NODE *args;
  2179. {
  2180.     return (binary(args,'E'));
  2181. }
  2182.  
  2183. /* xbitand - builtin function for bitwise and */
  2184. NODE *xbitand(args)
  2185.   NODE *args;
  2186. {
  2187.     return (binary(args,'&'));
  2188. }
  2189.  
  2190. /* xbitior - builtin function for bitwise inclusive or */
  2191. NODE *xbitior(args)
  2192.   NODE *args;
  2193. {
  2194.     return (binary(args,'|'));
  2195. }
  2196.  
  2197. /* xbitxor - builtin function for bitwise exclusive or */
  2198. NODE *xbitxor(args)
  2199.   NODE *args;
  2200. {
  2201.     return (binary(args,'^'));
  2202. }
  2203.  
  2204. /* binary - handle binary operations */
  2205. LOCAL NODE *binary(args,fcn)
  2206.   NODE *args; int fcn;
  2207. {
  2208.     FIXNUM ival,iarg;
  2209.     FLONUM fval,farg;
  2210.     NODE *arg;
  2211.     int imode;
  2212.  
  2213.     /* get the first argument */
  2214.     arg = xlarg(&args);
  2215.  
  2216.     /* set the type of the first argument */
  2217.     if (fixp(arg)) {
  2218.     ival = getfixnum(arg);
  2219.     imode = TRUE;
  2220.     }
  2221.     else if (floatp(arg)) {
  2222.     fval = getflonum(arg);
  2223.     imode = FALSE;
  2224.     }
  2225.     else
  2226.     xlerror("bad argument type",arg);
  2227.  
  2228.     /* treat '-' with a single argument as a special case */
  2229.     if (fcn == '-' && args == NIL)
  2230.     if (imode)
  2231.         ival = -ival;
  2232.     else
  2233.         fval = -fval;
  2234.  
  2235.     /* handle each remaining argument */
  2236.     while (args) {
  2237.  
  2238.     /* get the next argument */
  2239.     arg = xlarg(&args);
  2240.  
  2241.     /* check its type */
  2242.     if (fixp(arg))
  2243.         if (imode) iarg = getfixnum(arg);
  2244.         else farg = (FLONUM)getfixnum(arg);
  2245.     else if (floatp(arg))
  2246.         if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
  2247.         else farg = getflonum(arg);
  2248.     else
  2249.         xlerror("bad argument type",arg);
  2250.  
  2251.     /* accumulate the result value */
  2252.     if (imode)
  2253.         switch (fcn) {
  2254.         case '+':    ival += iarg; break;
  2255.         case '-':    ival -= iarg; break;
  2256.         case '*':    ival *= iarg; break;
  2257.         case '/':    checkizero(iarg); ival /= iarg; break;
  2258.         case '%':    checkizero(iarg); ival %= iarg; break;
  2259.         case 'M':    if (iarg > ival) ival = iarg; break;
  2260.         case 'm':    if (iarg < ival) ival = iarg; break;
  2261.         case '&':    ival &= iarg; break;
  2262.         case '|':    ival |= iarg; break;
  2263.         case '^':    ival ^= iarg; break;
  2264.         default:    badiop();
  2265.         }
  2266.     else
  2267.         switch (fcn) {
  2268.         case '+':    fval += farg; break;
  2269.         case '-':    fval -= farg; break;
  2270.         case '*':    fval *= farg; break;
  2271.         case '/':    checkfzero(farg); fval /= farg; break;
  2272.         case 'M':    if (farg > fval) fval = farg; break;
  2273.         case 'm':    if (farg < fval) fval = farg; break;
  2274.         case 'E':    fval = pow(fval,farg); break;
  2275.         default:    badfop();
  2276.         }
  2277.     }
  2278.  
  2279.     /* return the result */
  2280.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  2281. }
  2282.  
  2283. /* checkizero - check for integer division by zero */
  2284. checkizero(iarg)
  2285.   FIXNUM iarg;
  2286. {
  2287.     if (iarg == 0)
  2288.     xlfail("division by zero");
  2289. }
  2290.  
  2291. /* checkfzero - check for floating point division by zero */
  2292. checkfzero(farg)
  2293.   FLONUM farg;
  2294. {
  2295.     if (farg == 0.0)
  2296.     xlfail("division by zero");
  2297. }
  2298.  
  2299. /* checkfneg - check for square root of a negative number */
  2300. checkfneg(farg)
  2301.   FLONUM farg;
  2302. {
  2303.     if (farg < 0.0)
  2304.     xlfail("square root of a negative number");
  2305. }
  2306.  
  2307. /* xbitnot - bitwise not */
  2308. NODE *xbitnot(args)
  2309.   NODE *args;
  2310. {
  2311.     return (unary(args,'~'));
  2312. }
  2313.  
  2314. /* xabs - builtin function for absolute value */
  2315. NODE *xabs(args)
  2316.   NODE *args;
  2317. {
  2318.     return (unary(args,'A'));
  2319. }
  2320.  
  2321. /* xadd1 - builtin function for adding one */
  2322. NODE *xadd1(args)
  2323.   NODE *args;
  2324. {
  2325.     return (unary(args,'+'));
  2326. }
  2327.  
  2328. /* xsub1 - builtin function for subtracting one */
  2329. NODE *xsub1(args)
  2330.   NODE *args;
  2331. {
  2332.     return (unary(args,'-'));
  2333. }
  2334.  
  2335. /* xsin - built-in function 'sin' */
  2336. NODE *xsin(args)
  2337.   NODE *args;
  2338. {
  2339.     return (unary(args,'S'));
  2340. }
  2341.  
  2342. /* xcos - built-in function 'cos' */
  2343. NODE *xcos(args)
  2344.   NODE *args;
  2345. {
  2346.     return (unary(args,'C'));
  2347. }
  2348.  
  2349. /* xtan - built-in function 'tan' */
  2350. NODE *xtan(args)
  2351.   NODE *args;
  2352. {
  2353.     return (unary(args,'T'));
  2354. }
  2355.  
  2356. /* xexp - built-in function 'exp' */
  2357. NODE *xexp(args)
  2358.   NODE *args;
  2359. {
  2360.     return (unary(args,'E'));
  2361. }
  2362.  
  2363. /* xsqrt - built-in function 'sqrt' */
  2364. NODE *xsqrt(args)
  2365.   NODE *args;
  2366. {
  2367.     return (unary(args,'R'));
  2368. }
  2369.  
  2370. /* xfix - built-in function 'fix' */
  2371. NODE *xfix(args)
  2372.   NODE *args;
  2373. {
  2374.     return (unary(args,'I'));
  2375. }
  2376.  
  2377. /* xfloat - built-in function 'float' */
  2378. NODE *xfloat(args)
  2379.   NODE *args;
  2380. {
  2381.     return (unary(args,'F'));
  2382. }
  2383.  
  2384. /* xrand - built-in function 'random' */
  2385. NODE *xrand(args)
  2386.   NODE *args;
  2387. {
  2388.     return (unary(args,'R'));
  2389. }
  2390.  
  2391. /* unary - handle unary operations */
  2392. LOCAL NODE *unary(args,fcn)
  2393.   NODE *args; int fcn;
  2394. {
  2395.     FLONUM fval;
  2396.     FIXNUM ival;
  2397.     NODE *arg;
  2398.  
  2399.     /* get the argument */
  2400.     arg = xlarg(&args);
  2401.     xllastarg(args);
  2402.  
  2403.     /* check its type */
  2404.     if (fixp(arg)) {
  2405.     ival = getfixnum(arg);
  2406.     switch (fcn) {
  2407.     case '~':    ival = ~ival; break;
  2408.     case 'A':    ival = abs(ival); break;
  2409.     case '+':    ival++; break;
  2410.     case '-':    ival--; break;
  2411.     case 'I':    break;
  2412.     case 'F':    return (cvflonum((FLONUM)ival));
  2413.     case 'R':    ival = (FIXNUM)osrand((int)ival); break;
  2414.     default:    badiop();
  2415.     }
  2416.     return (cvfixnum(ival));
  2417.     }
  2418.     else if (floatp(arg)) {
  2419.     fval = getflonum(arg);
  2420.     switch (fcn) {
  2421.     case 'A':    fval = fabs(fval); break;
  2422.     case '+':    fval += 1.0; break;
  2423.     case '-':    fval -= 1.0; break;
  2424.     case 'S':    fval = sin(fval); break;
  2425.     case 'C':    fval = cos(fval); break;
  2426.     case 'T':    fval = tan(fval); break;
  2427.     case 'E':    fval = exp(fval); break;
  2428.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  2429.     case 'I':    return (cvfixnum((FIXNUM)fval));
  2430.     case 'F':    break;
  2431.     default:    badfop();
  2432.     }
  2433.     return (cvflonum(fval));
  2434.     }
  2435.     else
  2436.     xlerror("bad argument type",arg);
  2437.     /*NOTREACHED*/
  2438. }
  2439.  
  2440. /* xminusp - is this number negative? */
  2441. NODE *xminusp(args)
  2442.   NODE *args;
  2443. {
  2444.     return (predicate(args,'-'));
  2445. }
  2446.  
  2447. /* xzerop - is this number zero? */
  2448. NODE *xzerop(args)
  2449.   NODE *args;
  2450. {
  2451.     return (predicate(args,'Z'));
  2452. }
  2453.  
  2454. /* xplusp - is this number positive? */
  2455. NODE *xplusp(args)
  2456.   NODE *args;
  2457. {
  2458.     return (predicate(args,'+'));
  2459. }
  2460.  
  2461. /* xevenp - is this number even? */
  2462. NODE *xevenp(args)
  2463.   NODE *args;
  2464. {
  2465.     return (predicate(args,'E'));
  2466. }
  2467.  
  2468. /* xoddp - is this number odd? */
  2469. NODE *xoddp(args)
  2470.   NODE *args;
  2471. {
  2472.     return (predicate(args,'O'));
  2473. }
  2474.  
  2475. /* predicate - handle a predicate function */
  2476. LOCAL NODE *predicate(args,fcn)
  2477.   NODE *args; int fcn;
  2478. {
  2479.     FLONUM fval;
  2480.     FIXNUM ival;
  2481.     NODE *arg;
  2482.  
  2483.     /* get the argument */
  2484.     arg = xlarg(&args);
  2485.     xllastarg(args);
  2486.  
  2487.     /* check the argument type */
  2488.     if (fixp(arg)) {
  2489.     ival = getfixnum(arg);
  2490.     switch (fcn) {
  2491.     case '-':    ival = (ival < 0); break;
  2492.     case 'Z':    ival = (ival == 0); break;
  2493.     case '+':    ival = (ival > 0); break;
  2494.     case 'E':    ival = ((ival & 1) == 0); break;
  2495.     case 'O':    ival = ((ival & 1) != 0); break;
  2496.     default:    badiop();
  2497.     }
  2498.     }
  2499.     else if (floatp(arg)) {
  2500.     fval = getflonum(arg);
  2501.     switch (fcn) {
  2502.     case '-':    ival = (fval < 0); break;
  2503.     case 'Z':    ival = (fval == 0); break;
  2504.     case '+':    ival = (fval > 0); break;
  2505.     default:    badfop();
  2506.     }
  2507.     }
  2508.     else
  2509.     xlerror("bad argument type",arg);
  2510.  
  2511.     /* return the result value */
  2512.     return (ival ? true : NIL);
  2513. }
  2514.  
  2515. /* xlss - builtin function for < */
  2516. NODE *xlss(args)
  2517.   NODE *args;
  2518. {
  2519.     return (compare(args,'<'));
  2520. }
  2521.  
  2522. /* xleq - builtin function for <= */
  2523. NODE *xleq(args)
  2524.   NODE *args;
  2525. {
  2526.     return (compare(args,'L'));
  2527. }
  2528.  
  2529. /* equ - builtin function for = */
  2530. NODE *xequ(args)
  2531.   NODE *args;
  2532. {
  2533.     return (compare(args,'='));
  2534. }
  2535.  
  2536. /* xneq - builtin function for /= */
  2537. NODE *xneq(args)
  2538.   NODE *args;
  2539. {
  2540.     return (compare(args,'#'));
  2541. }
  2542.  
  2543. /* xgeq - builtin function for >= */
  2544. NODE *xgeq(args)
  2545.   NODE *args;
  2546. {
  2547.     return (compare(args,'G'));
  2548. }
  2549.  
  2550. /* xgtr - builtin function for > */
  2551. NODE *xgtr(args)
  2552.   NODE *args;
  2553. {
  2554.     return (compare(args,'>'));
  2555. }
  2556.  
  2557. /* compare - common compare function */
  2558. LOCAL NODE *compare(args,fcn)
  2559.   NODE *args; int fcn;
  2560. {
  2561.     NODE *arg1,*arg2;
  2562.     FIXNUM icmp;
  2563.     FLONUM fcmp;
  2564.     int imode;
  2565.  
  2566.     /* get the two arguments */
  2567.     arg1 = xlarg(&args);
  2568.     arg2 = xlarg(&args);
  2569.     xllastarg(args);
  2570.  
  2571.     /* do the compare */
  2572.     if (stringp(arg1) && stringp(arg2)) {
  2573.     icmp = strcmp(getstring(arg1),getstring(arg2));
  2574.     imode = TRUE;
  2575.     }
  2576.     else if (fixp(arg1) && fixp(arg2)) {
  2577.     icmp = getfixnum(arg1) - getfixnum(arg2);
  2578.     imode = TRUE;
  2579.     }
  2580.     else if (floatp(arg1) && floatp(arg2)) {
  2581.     fcmp = getflonum(arg1) - getflonum(arg2);
  2582.     imode = FALSE;
  2583.     }
  2584.     else if (fixp(arg1) && floatp(arg2)) {
  2585.     fcmp = (FLONUM)getfixnum(arg1) - getflonum(arg2);
  2586.     imode = FALSE;
  2587.     }
  2588.     else if (floatp(arg1) && fixp(arg2)) {
  2589.     fcmp = getflonum(arg1) - (FLONUM)getfixnum(arg2);
  2590.     imode = FALSE;
  2591.     }
  2592.     else
  2593.     xlfail("expecting strings, integers or floats");
  2594.  
  2595.     /* compute result of the compare */
  2596.     if (imode)
  2597.     switch (fcn) {
  2598.     case '<':    icmp = (icmp < 0); break;
  2599.     case 'L':    icmp = (icmp <= 0); break;
  2600.     case '=':    icmp = (icmp == 0); break;
  2601.     case '#':    icmp = (icmp != 0); break;
  2602.     case 'G':    icmp = (icmp >= 0); break;
  2603.     case '>':    icmp = (icmp > 0); break;
  2604.     }
  2605.     else
  2606.     switch (fcn) {
  2607.     case '<':    icmp = (fcmp < 0.0); break;
  2608.     case 'L':    icmp = (fcmp <= 0.0); break;
  2609.     case '=':    icmp = (fcmp == 0.0); break;
  2610.     case '#':    icmp = (fcmp != 0.0); break;
  2611.     case 'G':    icmp = (fcmp >= 0.0); break;
  2612.     case '>':    icmp = (fcmp > 0.0); break;
  2613.     }
  2614.  
  2615.     /* return the result */
  2616.     return (icmp ? true : NIL);
  2617. }
  2618.  
  2619. /* badiop - bad integer operation */
  2620. LOCAL badiop()
  2621. {
  2622.     xlfail("bad integer operation");
  2623. }
  2624.  
  2625. /* badfop - bad floating point operation */
  2626. LOCAL badfop()
  2627. {
  2628.     xlfail("bad floating point operation");
  2629. }
  2630.  
  2631. SHAR_EOF
  2632. fi # end of overwriting check
  2633. #    End of shell archive
  2634. exit 0
  2635.